home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / TUT1-9.ZIP / TUTPROG8.BAK < prev    next >
Text File  |  1993-12-29  |  14KB  |  431 lines
  1. {$X+}
  2. USES Crt;
  3.  
  4. CONST VGA = $A000;
  5.       MaxLines = 12;
  6.       Obj : Array [1..MaxLines,1..2,1..3] of integer =
  7.         (
  8.         ((-10,-10,-10),(10,-10,-10)),((-10,-10,-10),(-10,10,-10)),
  9.         ((-10,10,-10),(10,10,-10)),((10,-10,-10),(10,10,-10)),
  10.         ((-10,-10,10),(10,-10,10)),((-10,-10,10),(-10,10,10)),
  11.         ((-10,10,10),(10,10,10)),((10,-10,10),(10,10,10)),
  12.         ((-10,-10,10),(-10,-10,-10)),((-10,10,10),(-10,10,-10)),
  13.         ((10,10,10),(10,10,-10)),((10,-10,10),(10,-10,-10))
  14.         );  { The 3-D coordinates of our object ... stored as (X1,Y1,Z1), }
  15.             { (X2,Y2,Z2) ... for the two ends of a line }
  16.  
  17.  
  18. Type Point = Record
  19.                x,y,z:real;                { The data on every point we rotate}
  20.              END;
  21.      Virtual = Array [1..64000] of byte;  { The size of our Virtual Screen }
  22.      VirtPtr = ^Virtual;                  { Pointer to the virtual screen }
  23.  
  24.  
  25. VAR Lines : Array [1..MaxLines,1..2] of Point;  { The base object rotated }
  26.     Translated : Array [1..MaxLines,1..2] of Point; { The rotated object }
  27.     Xoff,Yoff,Zoff:Integer;               { Used for movement of the object }
  28.     lookup : Array [0..360,1..2] of real; { Our sin and cos lookup table }
  29.     Virscr : VirtPtr;                     { Our first Virtual screen }
  30.     Vaddr  : word;                        { The segment of our virtual screen}
  31.  
  32.  
  33. {──────────────────────────────────────────────────────────────────────────}
  34. Procedure SetMCGA;  { This procedure gets you into 320x200x256 mode. }
  35. BEGIN
  36.   asm
  37.      mov        ax,0013h
  38.      int        10h
  39.   end;
  40. END;
  41.  
  42.  
  43. {──────────────────────────────────────────────────────────────────────────}
  44. Procedure SetText;  { This procedure returns you to text mode.  }
  45. BEGIN
  46.   asm
  47.      mov        ax,0003h
  48.      int        10h
  49.   end;
  50. END;
  51.  
  52. {──────────────────────────────────────────────────────────────────────────}
  53. Procedure Cls (Where:word;Col : Byte);
  54.    { This clears the screen to the specified color }
  55. BEGIN
  56.      asm
  57.         push    es
  58.         mov     cx, 32000;
  59.         mov     es,[where]
  60.         xor     di,di
  61.         mov     al,[col]
  62.         mov     ah,al
  63.         rep     stosw
  64.         pop     es
  65.      End;
  66. END;
  67.  
  68. {──────────────────────────────────────────────────────────────────────────}
  69. Procedure SetUpVirtual;
  70.    { This sets up the memory needed for the virtual screen }
  71. BEGIN
  72.   GetMem (VirScr,64000);
  73.   vaddr := seg (virscr^);
  74. END;
  75.  
  76.  
  77. {──────────────────────────────────────────────────────────────────────────}
  78. Procedure ShutDown;
  79.    { This frees the memory used by the virtual screen }
  80. BEGIN
  81.   FreeMem (VirScr,64000);
  82. END;
  83.  
  84.  
  85. {──────────────────────────────────────────────────────────────────────────}
  86. procedure flip(source,dest:Word);
  87.   { This copies the entire screen at "source" to destination }
  88. begin
  89.   asm
  90.     push    ds
  91.     mov     ax, [Dest]
  92.     mov     es, ax
  93.     mov     ax, [Source]
  94.     mov     ds, ax
  95.     xor     si, si
  96.     xor     di, di
  97.     mov     cx, 32000
  98.     rep     movsw
  99.     pop     ds
  100.   end;
  101. end;
  102.  
  103.  
  104. {──────────────────────────────────────────────────────────────────────────}
  105. Procedure Pal(Col,R,G,B : Byte);
  106.   { This sets the Red, Green and Blue values of a certain color }
  107. Begin
  108.    asm
  109.       mov    dx,3c8h
  110.       mov    al,[col]
  111.       out    dx,al
  112.       inc    dx
  113.       mov    al,[r]
  114.       out    dx,al
  115.       mov    al,[g]
  116.       out    dx,al
  117.       mov    al,[b]
  118.       out    dx,al
  119.    end;
  120. End;
  121.  
  122.  
  123. {──────────────────────────────────────────────────────────────────────────}
  124. Function rad (theta : real) : real;
  125.   {  This calculates the degrees of an angle }
  126. BEGIN
  127.   rad := theta * pi / 180
  128. END;
  129.  
  130.  
  131. {──────────────────────────────────────────────────────────────────────────}
  132. Procedure SetUpPoints;
  133.   { This sets the basic offsets of the object, creates the lookup table and
  134.     moves the object from a constant to a variable }
  135. VAR loop1:integer;
  136. BEGIN
  137.   Xoff:=160;
  138.   Yoff:=100;
  139.   Zoff:=-256;
  140.   For loop1:=0 to 360 do BEGIN
  141.     lookup [loop1,1]:=sin (rad (loop1));
  142.     lookup [loop1,2]:=cos (rad (loop1));
  143.   END;
  144.   For loop1:=1 to MaxLines do BEGIN
  145.     Lines [loop1,1].x:=Obj [loop1,1,1];
  146.     Lines [loop1,1].y:=Obj [loop1,1,2];
  147.     Lines [loop1,1].z:=Obj [loop1,1,3];
  148.     Lines [loop1,2].x:=Obj [loop1,2,1];
  149.     Lines [loop1,2].y:=Obj [loop1,2,2];
  150.     Lines [loop1,2].z:=Obj [loop1,2,3];
  151.   END;
  152. END;
  153.  
  154.  
  155. {──────────────────────────────────────────────────────────────────────────}
  156. Procedure Putpixel (X,Y : Integer; Col : Byte; where:word);
  157.   { This puts a pixel on the screen by writing directly to memory. }
  158. BEGIN
  159.   Asm
  160.     mov     ax,[where]
  161.     mov     es,ax
  162.     mov     bx,[X]
  163.     mov     dx,[Y]
  164.     mov     di,bx
  165.     mov     bx, dx                  {; bx = dx}
  166.     shl     dx, 8
  167.     shl     bx, 6
  168.     add     dx, bx                  {; dx = dx + bx (ie y*320)}
  169.     add     di, dx                  {; finalise location}
  170.     mov     al, [Col]
  171.     stosb
  172.   End;
  173. END;
  174.  
  175.  
  176.  
  177. {──────────────────────────────────────────────────────────────────────────}
  178. Procedure Line(a,b,c,d:integer;col:byte;where:word);
  179.   { This draws a solid line from a,b to c,d in colour col }
  180.   function sgn(a:real):integer;
  181.   begin
  182.        if a>0 then sgn:=+1;
  183.        if a<0 then sgn:=-1;
  184.        if a=0 then sgn:=0;
  185.   end;
  186. var i,s,d1x,d1y,d2x,d2y,u,v,m,n:integer;
  187. begin
  188.      u:= c - a;
  189.      v:= d - b;
  190.      d1x:= SGN(u);
  191.      d1y:= SGN(v);
  192.      d2x:= SGN(u);
  193.      d2y:= 0;
  194.      m:= ABS(u);
  195.      n := ABS(v);
  196.      IF NOT (M>N) then
  197.      BEGIN
  198.           d2x := 0 ;
  199.           d2y := SGN(v);
  200.           m := ABS(v);
  201.           n := ABS(u);
  202.      END;
  203.      s := m shr 1;
  204.      FOR i := 0 TO m DO
  205.      BEGIN
  206.           putpixel(a,b,col,where);
  207.           s := s + n;
  208.           IF not (s<m) THEN
  209.           BEGIN
  210.                s := s - m;
  211.                a:= a + d1x;
  212.                b := b + d1y;
  213.           END
  214.           ELSE
  215.           BEGIN
  216.                a := a + d2x;
  217.                b := b + d2y;
  218.           END;
  219.      end;
  220. END;
  221.  
  222.  
  223. {──────────────────────────────────────────────────────────────────────────}
  224. Procedure DrawLogo;
  225.   { This draws 'ASPHYXIA' at the top of the screen in little balls }
  226. CONST ball : Array [1..5,1..5] of byte =
  227.          ((0,1,1,1,0),
  228.           (1,4,3,2,1),
  229.           (1,3,3,2,1),
  230.           (1,2,2,2,1),
  231.           (0,1,1,1,0));
  232.  
  233. VAR Logo : Array [1..5] of String;
  234.     loop1,loop2,loop3,loop4:integer;
  235. BEGIN
  236.   pal (13,0,63,0);
  237.   pal (1,0,0,40);
  238.   pal (2,0,0,45);
  239.   pal (3,0,0,50);
  240.   pal (4,0,0,60);
  241.   Logo[1]:=' O  OOO OOO O O O O O O OOO  O ';
  242.   Logo[2]:='O O O   O O O O O O O O  O  O O';
  243.   Logo[3]:='OOO OOO OOO OOO  O   O   O  OOO';
  244.   Logo[4]:='O O   O O   O O  O  O O  O  O O';
  245.   Logo[5]:='O O OOO O   O O  O  O O OOO O O';
  246.   For loop1:=1 to 5 do
  247.     For loop2:=1 to 31 do
  248.       if logo[loop1][loop2]='O' then
  249.         For loop3:=1 to 5 do
  250.           For loop4:=1 to 5 do
  251.             putpixel (loop2*10+loop3,loop1*4+loop4,ball[loop3,loop4],vaddr);
  252. END;
  253.  
  254.  
  255.  
  256. {──────────────────────────────────────────────────────────────────────────}
  257. Procedure RotatePoints (X,Y,Z:Integer);
  258.   { This rotates object lines by X,Y and Z; then places the result in
  259.     TRANSLATED }
  260. VAR loop1:integer;
  261.     temp:point;
  262. BEGIN
  263.   For loop1:=1 to maxlines do BEGIN
  264.     temp.x:=lines[loop1,1].x;
  265.     temp.y:=lookup[x,2]*lines[loop1,1].y - lookup[x,1]*lines[loop1,1].z;
  266.     temp.z:=lookup[x,1]*lines[loop1,1].y + lookup[x,2]*lines[loop1,1].z;
  267.  
  268.     translated[loop1,1]:=temp;
  269.  
  270.     If y>0 then BEGIN
  271.       temp.x:=lookup[y,2]*translated[loop1,1].x - lookup[y,1]*translated[loop1,1].y;
  272.       temp.y:=lookup[y,1]*translated[loop1,1].x + lookup[y,2]*translated[loop1,1].y;
  273.       temp.z:=translated[loop1,1].z;
  274.       translated[loop1,1]:=temp;
  275.     END;
  276.  
  277.     If z>0 then BEGIN
  278.       temp.x:=lookup[z,2]*translated[loop1,1].x + lookup[z,1]*translated[loop1,1].z;
  279.       temp.y:=translated[loop1,1].y;
  280.       temp.z:=-lookup[z,1]*translated[loop1,1].x + lookup[z,2]*translated[loop1,1].z;
  281.       translated[loop1,1]:=temp;
  282.     END;
  283.  
  284.     temp.x:=lines[loop1,2].x;
  285.     temp.y:=cos (rad(X))*lines[loop1,2].y - sin (rad(X))*lines[loop1,2].z;
  286.     temp.z:=sin (rad(X))*lines[loop1,2].y + cos (rad(X))*lines[loop1,2].z;
  287.  
  288.     translated[loop1,2]:=temp;
  289.  
  290.     If y>0 then BEGIN
  291.       temp.x:=cos (rad(Y))*translated[loop1,2].x - sin (rad(Y))*translated[loop1,2].y;
  292.       temp.y:=sin (rad(Y))*translated[loop1,2].x + cos (rad(Y))*translated[loop1,2].y;
  293.       temp.z:=translated[loop1,2].z;
  294.       translated[loop1,2]:=temp;
  295.     END;
  296.  
  297.     If z>0 then BEGIN
  298.       temp.x:=cos (rad(Z))*translated[loop1,2].x + sin (rad(Z))*translated[loop1,2].z;
  299.       temp.y:=translated[loop1,2].y;
  300.       temp.z:=-sin (rad(Z))*translated[loop1,2].x + cos (rad(Z))*translated[loop1,2].z;
  301.       translated[loop1,2]:=temp;
  302.     END;
  303.   END;
  304. END;
  305.  
  306.  
  307.  
  308. {──────────────────────────────────────────────────────────────────────────}
  309. Procedure DrawPoints;
  310.   { This draws the translated object to the virtual screen }
  311. VAR loop1:Integer;
  312.     nx,ny,nx2,ny2:integer;
  313.     temp:integer;
  314. BEGIN
  315.   For loop1:=1 to MaxLines do BEGIN
  316.     If (translated[loop1,1].z+zoff<0) and (translated[loop1,2].z+zoff<0) then BEGIN
  317.       temp:=round (translated[loop1,1].z+zoff);
  318.       nx :=round (256*translated[loop1,1].X) div temp+xoff;
  319.       ny :=round (256*translated[loop1,1].Y) div temp+yoff;
  320.       temp:=round (translated[loop1,2].z+zoff);
  321.       nx2:=round (256*translated[loop1,2].X) div temp+xoff;
  322.       ny2:=round (256*translated[loop1,2].Y) div temp+yoff;
  323.       If (NX > 0) and (NX < 320) and (NY > 25) and (NY < 200) and
  324.          (NX2> 0) and (NX2< 320) and (NY2> 25) and (NY2< 200) then
  325.            line (nx,ny,nx2,ny2,13,vaddr);
  326.     END;
  327.   END;
  328. END;
  329.  
  330. {──────────────────────────────────────────────────────────────────────────}
  331. Procedure ClearPoints;
  332.   { This clears the translated object from the virtual screen ... believe it
  333.     or not, this is faster then a straight "cls (vaddr,0)" }
  334. VAR loop1:Integer;
  335.     nx,ny,nx2,ny2:Integer;
  336.     temp:integer;
  337. BEGIN
  338.   For loop1:=1 to MaxLines do BEGIN
  339.     If (translated[loop1,1].z+zoff<0) and (translated[loop1,2].z+zoff<0) then BEGIN
  340.       temp:=round (translated[loop1,1].z+zoff);
  341.       nx :=round (256*translated[loop1,1].X) div temp+xoff;
  342.       ny :=round (256*translated[loop1,1].Y) div temp+yoff;
  343.       temp:=round (translated[loop1,2].z+zoff);
  344.       nx2:=round (256*translated[loop1,2].X) div temp+xoff;
  345.       ny2:=round (256*translated[loop1,2].Y) div temp+yoff;
  346.       If (NX > 0) and (NX < 320) and (NY > 25) and (NY < 200) and
  347.          (NX2> 0) and (NX2< 320) and (NY2> 25) and (NY2< 200) then
  348.            line (nx,ny,nx2,ny2,0,vaddr);
  349.     END;
  350.   END;
  351. END;
  352.  
  353.  
  354. {──────────────────────────────────────────────────────────────────────────}
  355. Procedure MoveAround;
  356.   { This is the main display procedure. Firstly it brings the object towards
  357.     the viewer by increasing the Zoff, then passes control to the user }
  358. VAR deg,loop1:integer;
  359.     ch:char;
  360. BEGIN
  361.   deg:=0;
  362.   ch:=#0;
  363.   Cls (vaddr,0);
  364.   DrawLogo;
  365.   For loop1:=-256 to -40 do BEGIN
  366.     zoff:=loop1*2;
  367.     DrawPoints;
  368.     flip (vaddr,vga);
  369.     ClearPoints;
  370.     RotatePoints (deg,deg,deg);
  371.     deg:=(deg+5) mod 360;
  372.   END;
  373.  
  374.   Repeat
  375.     if keypressed then BEGIN
  376.       ch:=upcase (Readkey);
  377.       Case ch of 'A' : zoff:=zoff+5;
  378.                  'Z' : zoff:=zoff-5;
  379.                  ',' : xoff:=xoff-5;
  380.                  '.' : xoff:=xoff+5;
  381.                  'S' : yoff:=yoff-5;
  382.                  'X' : yoff:=yoff+5;
  383.       END;
  384.     END;
  385.     DrawPoints;
  386.     flip (vaddr,vga);
  387.     ClearPoints;
  388.     RotatePoints (deg,deg,deg);
  389.     deg:=(deg+5) mod 360;
  390.   Until ch=#27;
  391. END;
  392.  
  393.  
  394. BEGIN
  395.   SetUpVirtual;
  396.   Writeln ('Greetings and salutations! Hope you had a great Christmas and New');
  397.   Writeln ('year! ;-) ... Anyway, this tutorial is on 3-D, so this is what is');
  398.   Writeln ('going to happen ... a wireframe square will come towards you.');
  399.   Writeln ('When it gets close, you get control. "A" and "Z" control the Z');
  400.   Writeln ('movement, "," and "." control the X movement, and "S" and "X"');
  401.   Writeln ('control the Y movement. I have not included rotation control, but');
  402.   Writeln ('it should be easy enough to put in yourself ... if you have any');
  403.   Writeln ('hassles, leave me mail.');
  404.   Writeln;
  405.   Writeln ('Read the main text file for ideas on improving this code ... and');
  406.   Writeln ('welcome to the world of 3-D!');
  407.   writeln;
  408.   writeln;
  409.   Write ('  Hit any key to contine ...');
  410.   Readkey;
  411.   SetMCGA;
  412.   SetUpPoints;
  413.   MoveAround;
  414.   SetText;
  415.   ShutDown;
  416.   Writeln ('All done. This concludes the eigth sample program in the ASPHYXIA');
  417.   Writeln ('Training series. You may reach DENTHOR under the names of GRANT');
  418.   Writeln ('SMITH/DENTHOR/ASPHYXIA on the ASPHYXIA BBS. I am also an avid');
  419.   Writeln ('Connectix BBS user, and occasionally read RSAProg.');
  420.   Writeln ('For discussion purposes, I am also the moderator of the Programming');
  421.   Writeln ('newsgroup on the For Your Eyes Only BBS.');
  422.   Writeln ('The numbers are available in the main text. You may also write to me at:');
  423.   Writeln ('             Grant Smith');
  424.   Writeln ('             P.O. Box 270');
  425.   Writeln ('             Kloof');
  426.   Writeln ('             3640');
  427.   Writeln ('I hope to hear from you soon!');
  428.   Writeln; Writeln;
  429.   Write   ('Hit any key to exit ...');
  430.   Readkey;
  431. END.